home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Protocol / file.pm < prev    next >
Encoding:
Perl POD Document  |  2008-04-11  |  3.7 KB  |  149 lines
  1. package LWP::Protocol::file;
  2.  
  3. require LWP::Protocol;
  4. @ISA = qw(LWP::Protocol);
  5.  
  6. use strict;
  7.  
  8. require LWP::MediaTypes;
  9. require HTTP::Request;
  10. require HTTP::Response;
  11. require HTTP::Status;
  12. require HTTP::Date;
  13.  
  14.  
  15. sub request
  16. {
  17.     my($self, $request, $proxy, $arg, $size) = @_;
  18.  
  19.     LWP::Debug::trace('()');
  20.  
  21.     $size = 4096 unless defined $size and $size > 0;
  22.  
  23.     # check proxy
  24.     if (defined $proxy)
  25.     {
  26.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  27.                   'You can not proxy through the filesystem';
  28.     }
  29.  
  30.     # check method
  31.     my $method = $request->method;
  32.     unless ($method eq 'GET' || $method eq 'HEAD') {
  33.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  34.                   'Library does not allow method ' .
  35.                   "$method for 'file:' URLs";
  36.     }
  37.  
  38.     # check url
  39.     my $url = $request->url;
  40.  
  41.     my $scheme = $url->scheme;
  42.     if ($scheme ne 'file') {
  43.     return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  44.                "LWP::Protocol::file::request called for '$scheme'";
  45.     }
  46.  
  47.     # URL OK, look at file
  48.     my $path  = $url->file;
  49.  
  50.     # test file exists and is readable
  51.     unless (-e $path) {
  52.     return new HTTP::Response &HTTP::Status::RC_NOT_FOUND,
  53.                   "File `$path' does not exist";
  54.     }
  55.     unless (-r _) {
  56.     return new HTTP::Response &HTTP::Status::RC_FORBIDDEN,
  57.                   'User does not have read permission';
  58.     }
  59.  
  60.     # looks like file exists
  61.     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
  62.        $atime,$mtime,$ctime,$blksize,$blocks)
  63.         = stat(_);
  64.  
  65.     # XXX should check Accept headers?
  66.  
  67.     # check if-modified-since
  68.     my $ims = $request->header('If-Modified-Since');
  69.     if (defined $ims) {
  70.     my $time = HTTP::Date::str2time($ims);
  71.     if (defined $time and $time >= $mtime) {
  72.         return new HTTP::Response &HTTP::Status::RC_NOT_MODIFIED,
  73.                       "$method $path";
  74.     }
  75.     }
  76.  
  77.     # Ok, should be an OK response by now...
  78.     my $response = new HTTP::Response &HTTP::Status::RC_OK;
  79.  
  80.     # fill in response headers
  81.     $response->header('Last-Modified', HTTP::Date::time2str($mtime));
  82.  
  83.     if (-d _) {         # If the path is a directory, process it
  84.     # generate the HTML for directory
  85.     opendir(D, $path) or
  86.        return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  87.                      "Cannot read directory '$path': $!";
  88.     my(@files) = sort readdir(D);
  89.     closedir(D);
  90.  
  91.     # Make directory listing
  92.     require URI::Escape;
  93.     require HTML::Entities;
  94.         my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
  95.     for (@files) {
  96.         my $furl = URI::Escape::uri_escape($_);
  97.             if ( -d "$pathe$_" ) {
  98.                 $furl .= '/';
  99.                 $_ .= '/';
  100.             }
  101.         my $desc = HTML::Entities::encode($_);
  102.         $_ = qq{<LI><A HREF="$furl">$desc</A>};
  103.     }
  104.     # Ensure that the base URL is "/" terminated
  105.     my $base = $url->clone;
  106.     unless ($base->path =~ m|/$|) {
  107.         $base->path($base->path . "/");
  108.     }
  109.     my $html = join("\n",
  110.             "<HTML>\n<HEAD>",
  111.             "<TITLE>Directory $path</TITLE>",
  112.             "<BASE HREF=\"$base\">",
  113.             "</HEAD>\n<BODY>",
  114.             "<H1>Directory listing of $path</H1>",
  115.             "<UL>", @files, "</UL>",
  116.             "</BODY>\n</HTML>\n");
  117.  
  118.     $response->header('Content-Type',   'text/html');
  119.     $response->header('Content-Length', length $html);
  120.     $html = "" if $method eq "HEAD";
  121.  
  122.     return $self->collect_once($arg, $response, $html);
  123.  
  124.     }
  125.  
  126.     # path is a regular file
  127.     $response->header('Content-Length', $filesize);
  128.     LWP::MediaTypes::guess_media_type($path, $response);
  129.  
  130.     # read the file
  131.     if ($method ne "HEAD") {
  132.     open(F, $path) or return new
  133.         HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  134.                "Cannot read file '$path': $!");
  135.     binmode(F);
  136.     $response =  $self->collect($arg, $response, sub {
  137.         my $content = "";
  138.         my $bytes = sysread(F, $content, $size);
  139.         return \$content if $bytes > 0;
  140.         return \ "";
  141.     });
  142.     close(F);
  143.     }
  144.  
  145.     $response;
  146. }
  147.  
  148. 1;
  149.